home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / DevTools / debugger < prev    next >
Encoding:
Text File  |  1994-04-06  |  28.9 KB  |  1,263 lines
  1. \ Debugger
  2. \
  3. \ To use this debugger, surround the code you
  4. \ want debugged with debug{ ..... }debug
  5. \ then compile it.  The debugger will compile
  6. \ names embedded in the code.
  7. \ Then enter:   DEBUG  name     to debug a
  8. \ named Forth routine.
  9. \ Enter '?' in debugger for menu.
  10. \
  11. \ For example:
  12. \    DEBUG{
  13. \    : FOO ( -- )
  14. \        23 dup + .
  15. \    ;
  16. \    }DEBUG
  17. \    DEBUG FOO
  18. \
  19. \ Author: Phil Burk
  20. \ Copyright 1988 Phil Burk
  21. \
  22. \ MOD: PLB 8/29/88 Check for second level of interpreter.
  23. \      For LOCALS and other vectorred FINDs.
  24. \      Save Stack, HERE and PAD
  25. \      Don't use Assembler
  26. \ MOD: PLB 9/9/88 Use IF.FORGOTTEN }DEBUG
  27. \ MOD: PLB 9/13/88 Add HERE 256 dump
  28. \ MOD: PLB 11/15/88 Fixed line handling with FILL-TIB?
  29. \      Handle LF chars to allow DEBUG from CLI
  30. \ MOD: PLB 12/7/88 Added 'l' command, added window,
  31. \      removed call to DB.FILL-TIB?
  32. \ MOD: PLB 12/10/88 Display Relative addressing.
  33. \ MOD: PLB 12/15/88 Vector quit to close window.
  34. \ MOD: PLB 1/3/89 Save LASTSCAN before WORD
  35. \      Added multiple breakpoints.
  36. \ MOD: PLB 1/11/89 Cleanup RECURSION check, add DEBUG.RESET
  37. \ MOD: PLB 2/3/89 Save EMIT properly and use FAST I/O, add BYE
  38. \ MOD: PLB 2/7/89 Save HERE and PAD during debug.
  39. \ MOD: PLB 6/6/91 INCLUDE JU:LOCALS so that ';' is before debugger
  40. \        copy name to DB-PAD in DB.FIND
  41. \ MOD: PLB 7/2/91 Do not DB-WINPTR OFF so that windows can
  42. \       be closed with DEBUG.STOP after an error.
  43. \ 00001 18-aug-91  mdh     Incorporated XBLK
  44. \ 00002 PLB 11/14/91 Used $= so JU:LOCALS not needed. Now works
  45. \          with any redefinition of ; EXIT RETURN or ;M
  46. \ 00003 PLB 12/14/91 Fixed BREAKAT when DEBUG{ on by using DB-PAD2
  47. \ 00004 PLB 1/4/92 Fixed BREAKAT for words with locals by
  48. \        adding DB.RETURN.TO.RTS
  49. \ 00005 MDH 5/10/93 Increased db_MAX_NEST to 64 (from 32)
  50. \ 00005 MDH 4/5/94 Increased db_MAX_NEST to 96 (from 64)
  51.  
  52. decimal
  53. include? tolower ju:char-macros
  54.  
  55. ANEW TASK-DEBUGGER
  56. decimal
  57.  
  58. : SAVE.REGS ( -- )
  59.     [ $ 48e7,fefc , ] inline
  60. ;
  61. : RESTORE.REGS ( -- )
  62.     [ $ 4cdf,3f7f , ] inline
  63. ;
  64.  
  65. : PUSH.REGS ( -- a7-a0/d7-d0 )
  66.     [ $ 2D07 w, \ move.l tos,-(dsp)
  67.       $ 48E6FFFF , \ movem.l d0-d7/a0-a7,-(dsp)
  68.       $ 2E1E w, \ move.l (dsp)+,tos
  69.     ]
  70. ;
  71.  
  72. : .REG  ( reg -- )
  73.     base @ >r HEX
  74.     s->d
  75.     <# # # # #
  76.        # # # # #>
  77.     type
  78.     r> base !
  79. ;
  80. : PRINT.4REGS  ( v4 v3 v2 v1 -- )
  81.     4 0 DO BL i 12 * 4 + emit-to-column .reg LOOP
  82. ;
  83.  
  84. : PRINT.16REGS  ( -- a7-a0/d7-d0 )
  85.     >newline ." Data Registers" cr
  86.     ." D0-3: " print.4regs cr
  87.     ." D4-7: " print.4regs cr
  88.     ." Address Registers" cr
  89.     ." A0-3: " print.4regs cr
  90.     ." A$-7: " print.4regs cr
  91. ;
  92.  
  93. : DUMP.REGS
  94.     save.regs
  95.     push.regs
  96.     print.16regs
  97.     restore.regs
  98. ;
  99.  
  100. \ This next word will be handy for calling from ASM code.
  101. variable db-SAVE-PC
  102. : DUMP.68000 ( -- , show PC & regs )
  103.     r@ >rel db-save-pc !
  104.     save.regs  push.regs
  105.     >newline db-save-pc @ ." PC = " .reg cr
  106.     print.16regs
  107.     restore.regs
  108. ;
  109.  
  110.     
  111. \ ---------------- ALL VARIABLES --------------------
  112. DEFER OLD.FIND
  113. what's find is old.find
  114. defer USER.BREAK?  ( address -- debug? )
  115. ' 0= is user.break?
  116. DEFER db.OLD.QUIT
  117. ' noop is db.old.quit
  118.  
  119. \ Variables used at compile time.
  120. variable db-PAD1 128 allot
  121. variable DB-PAD2 128 allot ( name to search for in BREAKAT 00003 )
  122. variable db-INSTALLED ( vectors installed )
  123. variable db-LATEST  ( save latest to tell when in new word)
  124. variable db-LAST-STATE  ( use to detect state transitions)
  125. variable db-START-STATE ( use to detect debug{ }debug errors )
  126. variable db-ABORT   ( use to avoid recursion in user.break?)
  127. variable db-SIZE-ADDR ( place where instruction size goes )
  128. variable db-CODE-ADDR ( address of code after debug )
  129. variable db-ENABLE  ( allow compilation of debug info )
  130.  
  131. \ Variables used when debugging.
  132. variable db-ACTIVE  ( control whether debug prints )
  133. variable db-TOUCH   ( control whether debug stops )
  134. variable db-GO      ( do another step )
  135. variable db-COUNT   ( only break if zero )
  136. variable db-CURRENT ( address of current step )
  137. variable db-NAME    ( address of current word name )
  138. variable db-DIVE    ( control traversing called words)
  139. variable db-LEVEL   ( level of nesting )
  140. variable db-TRIGGER ( level for debugger to come back )
  141. variable db-GOT-LF  ( getting an LF means in CLI !! )
  142. variable db-OLDCON  ( hold old console, true if dbg window open)
  143. variable db-WINPTR  ( pointer to debugger window )
  144. variable db-OUT     ( hold OUT when in debug )
  145. variable db-SAVE-RP ( save RP as place to jump back to )
  146. variable db-MODE    ( mode for traversing code )
  147. variable db-RESULT  ( result from searches and other things )
  148. variable db-RETPTR  ( return stack pointer at entry )
  149.  
  150. \ Variables used to control Debugger options.
  151. variable db-WINDOW  ( true if use own window )
  152. db-window on
  153. variable db-CHECK^D ( break on ^D if true )
  154. db-check^d on
  155.  
  156. 0 constant db_NORMAL_MODE  ( stop and debug code )
  157. 1 constant db_SEARCH_MODE  ( scan code for instruction )
  158. 2 constant db_ENTRY_MODE   ( find entry point )
  159. 3 constant db_SKIP_MODE    ( skip over code )
  160. \
  161. \ Support multiple breakpoints ---------------------------------
  162. \ Keep breakpoints in a table.
  163. \ Use by scanning for match.
  164. \ Add breakpoint at a zero location.
  165. \ Remove by scanning for match and setting to zero.
  166. 16 constant db_MAX_BREAKS
  167. variable db-NUM-BREAKS
  168. db_max_breaks array db-BREAK-TABLE
  169.  
  170. : NOBREAKS ( -- clear all breakpoints )
  171.     0 db-num-breaks !
  172. ;
  173. nobreaks
  174.  
  175. : DB.MATCH.BREAK  ( value -- index | -1 )
  176.     -1 swap   ( default flag )
  177.     0 db-break-table
  178.     db-num-breaks @ 0
  179.     DO  2dup @ =
  180.         IF >r >r drop i r> r> LEAVE
  181.         THEN cell+  ( fast linear search )
  182.     LOOP 2drop
  183. ;
  184.  
  185. : DB.ADD.BREAK ( value -- )
  186.     db-num-breaks @ db_max_breaks <
  187.     IF dup >newline ." Breakpoint added at " .hex cr
  188.        db-num-breaks @ db-break-table !
  189.        1 db-num-breaks +!
  190.     ELSE drop ." Breakpoint table full!"
  191.     THEN
  192. ;
  193.  
  194. : DB.CLEAR.BREAK ( value -- , remove from table )
  195.     db.match.break dup 0<
  196.     IF drop ."  Breakpoint not set!"
  197.     ELSE ( -- i )
  198.         dup 1+ db-num-breaks @ <
  199.         IF  ( -- i , pack table )
  200.             dup>r 1+ db-break-table  ( -- src )
  201.             dup cell-   ( -- src dst )
  202.             db-num-breaks @ r> - 1- 0 max cells move
  203.         ELSE drop
  204.         THEN
  205.         -1 db-num-breaks +!
  206.     THEN
  207. ;
  208.  
  209. : DB.SHOW.BREAKS ( -- )
  210.     >newline db-num-breaks @ 0
  211.     DO i .hex i db-break-table @ .hex cr
  212.     LOOP
  213. ;
  214.     
  215. \
  216. \ -----------------------------------------------------
  217. \ Calling Sequence Trace Stack
  218. \ This will be needed for CLONED programs that don't
  219. \ have NFAs so UNRAVEL won't work.
  220. 96 constant db_MAX_NEST   \ 00005
  221. db_max_nest array db-CALLS
  222. variable db-SP  ( number of things on stack )
  223. : DB.0SP  ( - , clear debug stack )
  224.     db-sp off
  225. ;
  226.  
  227. : DB.PUSH  ( value -- , push value onto stack )
  228.     db-sp @ db_max_nest <
  229.     IF db-sp @ db-calls !
  230.        1 db-sp +!  ( post increment )
  231.     ELSE drop
  232.        ." db.PUSH - debug stack overflow, nested too deep!" cr
  233.     THEN
  234. ;
  235.  
  236. : DB.TOS ( -- value ,  )
  237.     db-sp @ 1- ( predecrement ) db-calls @
  238. ;
  239.  
  240. : DB.DROP ( -- )
  241.     db-sp @ 0>
  242.     IF -1 db-sp +!
  243. \    ELSE
  244. \       ." db.DROP - already empty debug stack!"
  245.     THEN
  246. ;
  247.  
  248. : DB.POP ( -- value )
  249.     db.tos
  250.     db.drop
  251. ;
  252.  
  253. : DB.SAVE.CALLS ( -- )
  254.     r> ( return address )
  255.     0
  256.     BEGIN dup db-sp @ <
  257.     WHILE dup db-calls @ >r 1+
  258.     REPEAT drop
  259.     db-sp @ >r ( save count )
  260.     >r
  261. ;
  262.  
  263. : DB.RESTORE.CALLS ( -- )
  264.     r> ( return address )
  265.     r> dup db-sp !  ( get count )
  266.     BEGIN dup 0>
  267.     WHILE 1- r> over db-calls  !
  268.     REPEAT drop
  269.     >r
  270. ;
  271.  
  272. : DB.SHOW.CALLS ( -- , assume stack has $names )
  273.     >newline ." Calls: "
  274.     db-sp @ 0
  275.     DO  i 0> IF ."  --> "
  276.         THEN
  277.         i db-calls @ $type cr?
  278.     LOOP
  279. ;
  280.  
  281. : DB.TEST.CALLS ( -- )
  282.     db.0sp
  283.     " SWAP" db.push
  284.     " JABBER" db.push
  285.     " 1+" db.push
  286.     db.show.calls
  287.     db.0sp
  288. ;
  289.  
  290. \ -----------------------------------------------------
  291.  
  292. : DB.VARS.OFF ( -- , reset variables )
  293.     db-active off
  294.     db-count off
  295.     db-current off
  296.     db-dive off
  297.     db-level off
  298.     db-trigger off
  299.     db-abort off
  300.     db-latest off
  301.     db-last-state off
  302.     db-got-lf off
  303. \    db-oldcon off
  304. \    db-winptr off
  305.     db-mode @ off
  306. ;
  307.  
  308. : DB.SAVE.VARS  ( -- , save state )
  309.     r>  ( save return address )
  310.     db-active @ >r
  311.     db-go @ >r
  312.     db-count @ >r
  313.     db-current @ >r
  314.     db-dive @ >r
  315.     db-level @ >r
  316.     db-trigger @ >r
  317. \    db-oldcon @ >r
  318. \    db-winptr @ >r
  319.     db-save-rp @ >r
  320.     db-mode @ >r
  321.     db-retptr @ >r
  322.     db-out @ >r
  323.     db-name @ >r
  324.     db-touch @ >r
  325.     >r  ( restore return address )
  326. ;
  327. : DB.RESTORE.VARS  ( -- , restore state , must match DB.SAVE.VARS )
  328.     r>  ( save return address )
  329.     r> db-touch !
  330.     r> db-name !
  331.     r> db-out !
  332.     r> db-retptr !
  333.     r> db-mode !
  334.     r> db-save-rp !
  335. \    r> db-winptr !
  336. \    r> db-oldcon !
  337.     r> db-trigger !
  338.     r> db-level !
  339.     r> db-dive !
  340.     r> db-current !
  341.     r> db-count !
  342.     r> db-go !
  343.     r> db-active !
  344.     >r  ( restore return address )
  345. ;
  346.  
  347. : DB.SAVE.HERE ( -- , save here and 256 byte on R stack )
  348.     r>  ( save return address )
  349. \ Save HERE and next 256 bytes, saves PAD
  350.     64 0
  351.     BEGIN 2dup >
  352.     WHILE here over cells + @ >r 1+
  353.     REPEAT 2drop
  354.     here >r
  355.     >r ( for RTS )
  356. ;
  357.  
  358. : DB.RESTORE.HERE ( -- , restore HERE )
  359.     r>  ( return address )
  360.     r> HERE - warning" WARNING - HERE and PAD moved!"
  361.     64
  362.     BEGIN dup 0>
  363.     WHILE 1- r> over cells here + !
  364.     REPEAT drop
  365.     >r  ( for RTS )
  366. ;
  367.  
  368. : DB.PAUSE  ( -- , do several lines of forth input )
  369. \ Save data stack on return stack.
  370.     depth 0>
  371.     IF depth dup>r
  372.         xdup r> x>r
  373.     THEN
  374.     depth >r
  375. \
  376. \ Save miscellaneous.
  377.     flushemit  pushtib
  378.     span @ >r
  379.     db.save.calls
  380.     db.save.vars
  381.     db.vars.off
  382.     xblk @ >r ( 00001 )   fblk @ >r  blk @ >r
  383.     xblk off  ( 00001 )   fblk off  blk off  out off
  384. \
  385.     BEGIN cr ." Forth> " query #tib @ 0>
  386.     WHILE interpret
  387.     REPEAT
  388. \
  389.     r> blk !  r> fblk !    r> xblk ! ( 00001 )
  390.     db.restore.vars
  391.     db.restore.calls
  392.     r> span !
  393.     pulltib
  394. \
  395. \ Restore Data Stack
  396.     0sp r> dup 0>
  397.     IF xr>
  398.     ELSE drop
  399.     THEN
  400. ;
  401.  
  402. : DB.INPUT$ ( -- $string )
  403.     span @
  404.     db-pad1 1+
  405.     128 expect
  406.     span @ db-pad1 c!
  407.     span !
  408.     db-pad1
  409. ;
  410.  
  411. : DB.LF.INPUT$ ( -- , skip first LF if in CLI )
  412.     db-got-lf @
  413.     IF db.input$ c@ 0=
  414.        IF db.input$  ( try again )
  415.        ELSE db-pad1
  416.        THEN
  417.     ELSE db.input$
  418.     THEN
  419. ;
  420.  
  421. : DB.INPUT# ( -- N )
  422.     ." #> "
  423.     db.input$
  424.     number?
  425.     IF  dpl @ 0< ( single precision? )
  426.         IF drop
  427.         THEN
  428.     ELSE 0 ." Not valid, 0 used!" cr
  429.     THEN
  430. ;
  431.  
  432. : DB.S  ( -- , print stack )
  433.     >newline
  434.     depth 0<
  435.     IF ." Underflow!" 0sp  ( reset )
  436.     ELSE
  437.         depth 0=
  438.         IF ." Empty!"
  439.         ELSE
  440.             depth 10 >
  441.             IF ." <<<["
  442.             ELSE ." ["
  443.             THEN
  444.             base @ decimal
  445.             depth 1- 1 .r ." ] "
  446.             base !
  447.             depth 8 min 0
  448.             DO depth 8 min i - 1- pick . cr?
  449.             LOOP
  450.         THEN
  451.     THEN
  452. ;
  453.  
  454. : DB.RDEPTH  ( -- #retcells )
  455.     r0 @ db-retptr @ - cell/  20 -
  456.     0 max
  457. ;
  458.  
  459. : DB.RSTACK  ( -- , print return stack )
  460.     >newline
  461.     db.rdepth  10 >
  462.     IF ." <<<("
  463.     ELSE ." ("
  464.     THEN
  465.     base @ decimal
  466.     db.rdepth 1 .r ." ) "
  467.     base !
  468.     db.rdepth dup 30 - 0 max
  469.     DO r0 @  i 5 + cells - @ .hex cr?
  470.     LOOP
  471. ;
  472.  
  473. : DB.GET.SIZE ( -- size )
  474.     db-name @ dup c@ + c@ ascii 0 -
  475. ;
  476.  
  477. : DB.SKIP ( -- skip instruction )
  478.     db.get.size db-save-rp +!
  479. ;
  480.  
  481. \ Window I/O Control
  482. : SWAP.OUT ( -- , swap debugger out for systems )
  483.     out @ db-out @ out ! db-out !
  484. ;
  485.  
  486. defer DB-OLD-EMIT
  487. defer DB-OLD-FLUSHEMIT
  488. variable DB-OLD-FASTIO?
  489.  
  490. : DB.SET.VECTORS ( -- )
  491.     what's db-old-emit ' quit =
  492.     IF  flushemit
  493.         what's emit is db-old-emit
  494.         what's flushemit is db-old-flushemit
  495.         fastio? @ db-old-fastio? !
  496.         fast  ( comment out this line to make debug work with LOGTO )
  497.         ( But there may be problems with users redefining EMIT )
  498.         ( and recursing! )
  499.     THEN
  500. ;
  501.  
  502. : DB.RESET.VECTORS ( -- )
  503.     what's db-old-emit ' quit -
  504.     IF  what's db-old-emit is emit
  505.         what's db-old-flushemit is flushemit
  506.         db-old-fastio? @ fastio? !
  507.         ' quit is db-old-emit
  508.     THEN
  509. ;
  510.     
  511. : DB.WINDOW.ON  ( -- , use debugger window )
  512.     db-winptr @
  513.     IF  db.set.vectors
  514.         db-oldcon @ 0=
  515.         IF  console@ db-oldcon !
  516.             flushemit swap.out
  517.             db-winptr @ console!
  518.         THEN
  519.     THEN
  520. ;
  521.  
  522. : DB.WINDOW.OFF  ( -- , use normal window )
  523.     db-winptr @
  524.     IF  db-oldcon @
  525.         IF  flushemit db-oldcon @ console!
  526.             swap.out  db-oldcon off
  527.         THEN
  528.         db.reset.vectors
  529.     THEN
  530. ;
  531.  
  532. : DB.CLOSE.WINDOW ( -- , close debugger window )
  533.     db-winptr @
  534.     IF  db.window.off
  535.         db-winptr @ fclose
  536.         db-winptr off
  537.     THEN
  538. ;
  539.  
  540. : DB.CLEANUP ( -- )
  541.     db-active off db-trigger off
  542.     db.0sp
  543.     db.close.window
  544.     what's db.old.quit dup ' noop =
  545.     IF drop
  546.     ELSE is quit ' noop is db.old.quit
  547.     THEN 
  548. ;
  549.  
  550. : DB.QUIT ( -- , quit and reset vectors )
  551.     db.cleanup quit
  552. ;
  553.  
  554. : DB.OPEN.WINDOW ( -- , open debugger window )
  555.     db-window @
  556.     db-winptr @ 0= AND
  557.     IF  " RAW:0/20/640/120/JForth Debugger"
  558.         $fopen ?dup
  559.         IF db-winptr !
  560.         ELSE ." Debugger window could not be opened!" cr
  561.         THEN
  562.     THEN
  563.     what's db.old.quit ' noop =
  564.     IF \ Set quit vectors
  565.         what's quit is db.old.quit
  566.         ' db.quit is quit
  567.     THEN
  568. ;
  569.  
  570.  
  571. : WAIT?CR  ( -- , wait if key )
  572.     ?terminal
  573.     IF (key) drop
  574.         (key) drop
  575.     THEN cr
  576. ;
  577.  
  578. \ Interactive Command Parsing
  579. : DB.HELP ( -- )
  580.     wait?cr
  581.     ." JForth Debugger - PLB" wait?cr
  582.     ." Information:" wait?cr
  583.     ."   w - Where?, who called who" wait?cr
  584.     ."   6 - 680x0 register dump" wait?cr
  585.     ."   m - Memory dump from address on stack" wait?cr
  586.     ."   s - regular Stack dump" wait?cr
  587.     ."   r - Return stack hex dump" wait?cr
  588.     ."   h - HERE 256 DUMP , shows PAD too" wait?cr
  589.     ." Action:" wait?cr
  590.     ."   f - Forth, interpret one line" wait?cr
  591.     ."   x - drop one number from stack" wait?cr
  592.     ."   n - push a Number onto stack" wait?cr
  593.     ."   + - add a number to top of stack" wait?cr
  594.     ." Bases: 1 - decimal , 2 - binary , 3 - hex" wait?cr
  595.     ." User:  7,8,9 - DEBUG.USER.7,8,9" wait?cr
  596.     ." Control:" cr
  597.     ."   b - set the Breakpoint here" wait?cr
  598.     ."   c - Clear the breakpoint here" wait?cr
  599.     ."   # - enter # breaks to skip" wait?cr
  600.     ."   u - Up, continue until RTS" wait?cr
  601.     ."   j - Jump over next instruction" wait?cr
  602.     ."   z - set user.break? to 0= , disabled" wait?cr
  603.     ."   l - Look at code ?terminal until" wait?cr
  604.     ."   g - Go" wait?cr
  605.     ."   <SPACE> - single step on same level" wait?cr
  606.     ."   <CR> or d - dive down into word" wait?cr
  607.     ."   q - quit" wait?cr
  608. ;
  609.  
  610. defer debug.user.7 ' db.help is debug.user.7
  611. defer debug.user.8 ' db.help is debug.user.8
  612. defer debug.user.9 ' db.help is debug.user.9
  613.  
  614. : DB.PARSE  ( char -- continue? , act on char )
  615.     db-go off
  616.     tolower
  617.     CASE
  618.            $ 0D OF db-dive on db-go on
  619.                 ENDOF
  620.              BL OF db-dive off db-go on
  621.                 ENDOF
  622.         ascii u OF db-active off db-go on
  623.                    db-level @ db-trigger !
  624.                 ENDOF
  625.         ( ^D) 4 OF >newline ." Control-D break!" cr
  626.                 ENDOF
  627.              10 OF ( ignore line feed )
  628.                 ENDOF
  629.         ascii 1 OF decimal  >newline ." Decimal!" ENDOF
  630.         ascii 2 OF 2 base ! >newline ." Binary!"  ENDOF
  631.         ascii 3 OF hex  >newline ." Hexadecimal!" ENDOF
  632.         ascii 6 OF dump.regs ENDOF
  633.         ascii d OF db-dive on db-go on
  634.                 ENDOF
  635.         ascii f OF db.pause >newline
  636.                 ENDOF
  637.         ascii g OF db-active off db-go on
  638.                    db-trigger off
  639.                 ENDOF
  640.         ascii h OF here 256 dump
  641.                 ENDOF
  642.         ascii j OF db.skip ." Instruction Skipped!" db-go on
  643.                 ENDOF
  644.         ascii l OF db-touch off db-go on
  645.                 ENDOF
  646.         ascii m OF dup 32 dump
  647.                 ENDOF
  648.         ascii n OF >newline ." Push " db.input#
  649.                 ENDOF
  650.         ascii r OF db.rstack
  651.                 ENDOF
  652.         ascii s OF .s
  653.                 ENDOF
  654.         ascii w OF db.show.calls
  655.                 ENDOF
  656.         ascii x OF drop
  657.                 ENDOF
  658.         ascii + OF >newline ." Add " db.input# +
  659.                 ENDOF
  660.         ascii b OF db-current @ db.add.break >newline
  661.                 ENDOF
  662.         ascii c OF db-current @ db.clear.break >newline
  663.                 ENDOF
  664.         ascii # OF >newline ." Skip " db.input#
  665.                    1- 0 max db-count !
  666.                    db-active off db-go on
  667.                 ENDOF
  668.         ascii z OF ' 0= is user.break? >newline ENDOF
  669.         ascii q OF db.quit  ENDOF
  670.         ascii ? OF db.help
  671.                 ENDOF
  672.         ascii 7 OF debug.user.7 >newline ENDOF
  673.         ascii 8 OF debug.user.8 >newline ENDOF
  674.         ascii 9 OF debug.user.9 >newline ENDOF
  675.                 cr ." Unrecognized DEBUG command = "
  676.                 dup . dup emit cr
  677.                 ." Enter ? for help." cr
  678.     ENDCASE
  679.     db-go @
  680. ;
  681.  
  682. : DB.DISPLAY  ( -- , display current stack and word )
  683.     db.s cr
  684.     db-current @ .hex ." : "
  685.     ascii - 14 emit-to-column
  686.     ." ( " db-level @ 2* spaces ( indent )
  687.     db-name @ count 1- ( 1- to account for size suffix )
  688.     type space
  689.     bl 50 emit-to-column
  690.     ." |? "
  691. ;
  692.  
  693. : DB.INTERP ( -- , interpret debugger key commands )
  694.     BEGIN
  695.         db.display
  696.         db-got-lf @  ( in CLI with LFs coming? )
  697.         IF  (key) dup 10 = ( empty line, convert to <CR> )
  698.             IF  drop 13
  699.             ELSE BEGIN (key) 10 = UNTIL  ( wait for LF to clean up)
  700.             THEN
  701.         ELSE (key) dup 10 =
  702.             IF db-got-lf on
  703.             THEN
  704.         THEN
  705.         dup dup BL <
  706.         IF drop space
  707.         ELSE emit
  708.         THEN space
  709.         db.parse
  710.         flushemit
  711.     UNTIL
  712. ;
  713.  
  714. : DB.SAVE.STATUS  ( -- , save variables that DB touches )
  715.     r>
  716.     db.save.here
  717.     #digs @ >r
  718.     hld @ >r
  719.     state @ >r
  720.     >r
  721. ;
  722.  
  723. : DB.RESTORE.STATUS ( -- )
  724.     r>
  725.     r> state !
  726.     r> hld !
  727.     r> #digs !
  728.     db.restore.here
  729.     >r
  730. ;
  731.     
  732. : ($DEBUG) ( $string+size -- )
  733.     rp@ db-retptr !  ( snapshot return pointer for rdump )
  734.     db.save.status
  735.     >newline ascii - 57 emit-to-column
  736.     db-name !
  737.     db-touch @
  738.     IF db.interp
  739.     ELSE db.display
  740.         ?terminal
  741.         IF db-touch on
  742.         THEN
  743.     THEN
  744.     bl 56 emit-to-column ." ) "
  745.     flushemit
  746.     db.restore.status
  747. ;
  748.  
  749. .NEED SetSignal()
  750. : SetSignal()  ( value mask -- oldvalues )
  751.     call exec_lib SetSignal
  752. ;
  753. .THEN
  754.  
  755. : ?CONTROL-D   ( -- flag , true if control D hit )
  756.     0 $ 2000 setsignal()
  757.     $ 2000 and 0= 0=
  758. ;
  759.  
  760. \ Decision to display db.
  761. : DEBUG? ( address -- debug? )
  762. \ Give the debugger various chances to turn on if off.
  763.     db-current !
  764. \
  765. \ Check for debug back on for this level.
  766.     db-active @ 0=
  767.     IF db-level @ db-trigger @ <
  768.         IF db-active on
  769.            db-level db-trigger !
  770.         THEN
  771.     THEN
  772. \
  773. \ Check for breakpoint hit.
  774.     db-current @ db.match.break -1 >
  775.     IF  db-count @ 0=
  776.         IF  db-active on db-touch on
  777.             >newline ." Breakpoint Encountered!"
  778.         ELSE -1 db-count +!
  779.         THEN
  780.     THEN
  781. \
  782. \ Allow user test to turn on debugger.
  783.     db-abort @
  784.     IF  ." RECURSION! Don't compile words for USER.BREAK? with DEBUG{" cr
  785.         ." Hit a key" (key) drop
  786.         db-abort off abort
  787.     ELSE
  788.         db-abort on ( prevent dangerous recursion )
  789.         db-current @ user.break? dup ( give user chance to test )
  790.     THEN
  791.     IF  >newline ." USER.BREAK? caused break." cr
  792.         db-touch on
  793.     THEN
  794.     db-abort off
  795.  
  796.     db-active @ OR
  797.     db-check^D @
  798.     IF ?control-D OR
  799.     THEN
  800.     dup db-active !
  801. ;
  802.  
  803. $ 4E71 constant db_NOOP_CODE
  804.  
  805. : DB.MARKED? ( cfa -- if_debuggable? )
  806.     dup w@ db_noop_code =  dup 0=
  807.     IF >newline swap >name id. ."  not compiled with debug{" cr
  808.     ELSE nip
  809.     THEN
  810. ;
  811.  
  812. : $BREAKAT ( mode $name -- , find and set breakpoint)
  813. \ If mode is search, the string at db-pad2 will be used.
  814.     find
  815.     IF  dup db.marked?  ( mode cfa flag )
  816.         IF  db-mode @ >r
  817.             swap db-mode !
  818.             db-result off
  819.             execute
  820.             db-result @ ?dup
  821.             IF db.add.break
  822.             ELSE ."  Couldn't match " db-pad2 $type \ 00003
  823.             THEN
  824.             r> db-mode !
  825.         ELSE 2drop
  826.         THEN
  827.     ELSE nip ."  $BREAKAT - Couldn't FIND " ID.
  828.     THEN
  829. ;
  830.  
  831. : BREAKAT ( <name> <string> -- )
  832.     32 word
  833.     dp @ >r db-pad2 dp ! fileword r> dp ! \ string to db-pad2 , 00003
  834.     c@ 0=
  835.     IF db_entry_mode swap
  836.     ELSE db_search_mode swap
  837.     THEN  $breakat
  838. ;
  839.  
  840. \ These words are the entry points into the debugger.
  841. \ They must switch the window if open.
  842. : DB.CHECK.NAME ( $string+size -- match? )
  843.     dup db-name !
  844.     dup c@ db-pad2 c@ <
  845.     IF drop false  ( too big )
  846.     ELSE  count db-pad2 count swap >r min
  847.         r> text=?
  848.     THEN
  849. ;
  850.  
  851. : $DEBUG ( $string+size -- , called from code )
  852.     r@ >rel
  853.     save.regs
  854.     db-save-rp @ >r
  855.     dup db-save-rp !
  856.     db-mode @
  857.     CASE
  858.         db_normal_mode
  859.         OF  db.window.on
  860.             debug?
  861.             IF   ($debug)
  862.             ELSE drop
  863.             THEN
  864.             db.window.off
  865.         ENDOF
  866.         db_search_mode
  867.         OF  swap db.check.name
  868.             IF db-result !
  869.                db_skip_mode db-mode !
  870.             ELSE drop
  871.             THEN
  872.             db.skip
  873.         ENDOF
  874.         db_skip_mode
  875.         OF  drop db-name !
  876.             db.skip
  877.         ENDOF
  878.         db_entry_mode
  879.         OF  db-result ! db-name !
  880.             db.skip db_skip_mode db-mode !
  881.         ENDOF
  882.         ." Invalid Debugger Mode!" abort
  883.     ENDCASE
  884.     db-save-rp @
  885.     r> db-save-rp !
  886.     restore.regs
  887.     >abs rdrop >r
  888. ;
  889.  
  890. : $DB.ENTRY.NORMAL
  891.     1 db-level +!
  892.     db-dive @
  893.     IF  db-dive off
  894.     ELSE  ( don't dive into this !)
  895.         db-active @
  896.         IF  ( currently on? )
  897.             db-level @ db-trigger !
  898.             db-active off
  899.         THEN
  900.     THEN
  901.     db.window.on
  902.     debug?
  903.     IF  >newline ." Entering:  " $type
  904.         ."  >>>>>>>>>>>>>>>>>>>>>" cr
  905.     ELSE drop
  906.     THEN
  907.     db.window.off
  908. ;
  909.  
  910. : $DB.ENTRY  ( $string -- )
  911.     r@ >rel
  912.     save.regs
  913.     over db.push
  914.     db-mode @
  915.     CASE
  916.         db_normal_mode
  917.         OF  $db.entry.normal
  918.         ENDOF
  919.         nip nip
  920.     ENDCASE
  921.     restore.regs
  922. ;
  923.  
  924. : DB.RETURN.TO.RTS ( -- , advance return address to RTS, 00004 )
  925.     BEGIN
  926.         db-save-rp @ w@ $ 4E75 = not
  927.     WHILE
  928.         2 db-save-rp +!
  929.     REPEAT
  930. ;
  931.  
  932. : $DB.RETURN ( $string -- , called before return )
  933.     r@ >rel
  934.     save.regs
  935.     db-save-rp @ >r
  936.     dup db-save-rp !
  937.     db-mode @
  938.     CASE
  939.         db_normal_mode
  940.         OF
  941.             db.window.on
  942.             debug?
  943.             IF  >r " RTS0" ($debug) r>
  944.                 >newline ." Returning from: " $type
  945.                 ."  <<<<<<<<<<<<<<<<<<<<<" cr
  946.             ELSE drop
  947.             THEN
  948.             db.window.off
  949.             db-dive on
  950.             -1 db-level +!
  951.         ENDOF
  952.         db_search_mode
  953.         OF
  954.             2drop db.return.to.rts \ 00004
  955.         ENDOF
  956.         db_skip_mode
  957.         OF
  958.             2drop db.return.to.rts \ 00004
  959.         ENDOF
  960.         2drop
  961.     ENDCASE
  962.     db.drop
  963.     db-save-rp @
  964.     r> db-save-rp !
  965.     restore.regs
  966.     >abs rdrop >r
  967. ;
  968. \ ----------------------------
  969.  
  970. : DB.NEW.WORD? ( -- new? , true once if defining new word)
  971.     false >r  ( default )
  972.     state @
  973.     IF  db-last-state @ 0=  ( detect ] )
  974.         IF  latest db-latest @ - ( new word )
  975.             IF  rdrop true >r
  976.                 latest db-latest ! \ ." Start" cr
  977.             THEN
  978.         THEN
  979.     THEN
  980.     r>
  981. ;
  982.  
  983. : DB.NEW.METHOD? ( -- new? , true once if defining new word)
  984.     false >r  ( default )
  985.     state @
  986.     IF  db-last-state @ 0=  ( detect ] )
  987.         IF  current-method @ ?dup  ( inside method )
  988.             IF db-latest @ - ( new word )
  989.                IF  rdrop true >r
  990.                   current-method @ db-latest ! \ ." Start" cr
  991.                THEN
  992.             THEN
  993.         THEN
  994.     THEN
  995.     r>
  996. ;
  997.  
  998. : $>HERE ( $string -- )
  999.     here $move
  1000.     here c@ 1+ allot align
  1001. ;
  1002.     
  1003. : $LITERAL ( $string -- , compile literal string )
  1004.     compile ($")
  1005.     $>here
  1006. ; IMMEDIATE
  1007.  
  1008. : $NFALITERAL ( nfa -- , compile literal nfa )
  1009.     compile ($")
  1010.     count 31 and
  1011.     0 here !
  1012.     here $append
  1013.     here c@ 1+ allot align
  1014. ; IMMEDIATE
  1015.  
  1016. : DB.NAME>HERE  ( addr count -- , put string HERE)
  1017.     0 here !
  1018.     here $append
  1019.     " 0" count here $append
  1020.     here c@ 1+ allot
  1021.     here 1- db-size-addr !
  1022.     align
  1023. ;
  1024.  
  1025. : DB.UPDATE.SIZE ( -- , set size in previous instr )
  1026.     db-size-addr @
  1027.     IF  here db-code-addr @ -  ( size of inst )
  1028.         db-size-addr @ c@ + 255 min  ( clip to byte )
  1029.         db-size-addr @ c!
  1030.     THEN
  1031. ;
  1032.  
  1033. : DB.COMPILE.BODY ( -- )
  1034.     db-pad1 c@ 0>
  1035.     IF  db.update.size
  1036.         compile ($")
  1037.         db-pad1 count db.name>here
  1038.         compile $DEBUG
  1039.         here db-code-addr !
  1040.     THEN
  1041. ;
  1042.  
  1043. : DB.COMPILE.RETURN ( -- )
  1044.     db.update.size
  1045.     db-size-addr off
  1046.     db-LATEST @ [compile] $nfaliteral
  1047.     compile $db.RETURN
  1048. ;
  1049.  
  1050. : DB.COMPILE.ENTRY ( nfa -- )
  1051.     db_noop_code w,  ( compile noop as flag for debugger )
  1052.     [compile] $nfaliteral
  1053.     compile $db.ENTRY
  1054. ;
  1055.  
  1056. : DB.COMPILE (  name 0 | cfa 1 [imm] | cfa -1 -- SAME )
  1057.     2dup  ( n 0 n 0 | c t c t )
  1058. \
  1059. \ Compile following word if immediate for ' $ ..@ , etc.
  1060.     dup 1 =
  1061.     IF  lastscan @ $ 0A = 0=
  1062.         tib >in @ + c@ $ 0A = 0= AND
  1063.         tib >in @ + #tib @ >in @ - bl skip nip AND
  1064.         IF  >in @ lastscan @
  1065.             "  " count db-pad1 $append
  1066.             32 word count db-pad1 $append
  1067.             lastscan ! >in !
  1068.         THEN
  1069.     THEN
  1070. \
  1071. \ Compile entry handler if new ODE method.
  1072.     db.new.method?
  1073.     IF  current-method @ db.compile.entry
  1074.     ELSE 
  1075. \ Compile entry handler if new word.
  1076.         db.new.word?
  1077.         IF  LATEST db.compile.entry
  1078.         THEN
  1079.     THEN
  1080. \
  1081.     state @ db-last-state !
  1082. \
  1083. \ Special handling for special words.
  1084.     IF  
  1085.         CASE
  1086.         db-pad1 " ;"      $= ?OF db.compile.return ENDOF \ 00002
  1087.         db-pad1 " EXIT"   $= ?OF db.compile.return ENDOF \ 00002
  1088.         db-pad1 " RETURN" $= ?OF db.compile.return ENDOF \ 00002
  1089.         db-pad1 " ;M"     $= ?OF db.compile.return ENDOF \ 00002
  1090.         ' (      OF ( ." Ignore Comment" cr ) ENDOF
  1091.         ' \      OF ( ." Ignore Comment" cr ) ENDOF
  1092.         ' DOES>  OF db.compile.return
  1093.                     ( trick db.NEW.WORD?)
  1094.                     db-last-state off
  1095.                     db-latest off     ENDOF
  1096.             db.compile.body
  1097.         ENDCASE ( -- cfa true )
  1098.     ELSE ( -- name 0 name )
  1099.         db.compile.body
  1100.         2drop drop
  1101.         db-pad1 here $move  ( cuz old HERE clobbered )
  1102.         here 0
  1103.     THEN
  1104. ;
  1105.  
  1106. : IN.INTERPRET? ( raddr -- flag )
  1107.      >rel what's interpret dup 32 + within?
  1108. ;
  1109.  
  1110. : DB.FIND ( $name -- $name 0 | cfa 1 [imm] | cfa -1 )
  1111.     dup db-pad1 $move
  1112.     old.find
  1113.     state @
  1114.     IF ( -- cfa +-1|0)
  1115.         blk @ abort" DB.FIND not supported with BLOCK"
  1116.         db-enable @
  1117.         IF
  1118. \ Here is a ghastly kludge that will be replaced
  1119. \ when INTERPRET supports the debugger.
  1120. \ Search over broad range
  1121.             0 rdepth  2
  1122.             DO  i rpick in.interpret? OR
  1123.                 dup IF leave THEN
  1124.             LOOP
  1125.             IF  ( FIND called from interpreter )
  1126.                 depth >r
  1127.                 db.compile
  1128.                 depth r> - abort" Stack change!"
  1129.             THEN
  1130.         THEN
  1131.     THEN
  1132.     state @ 0=
  1133.     IF db-last-state off
  1134.     THEN
  1135. ;
  1136.  
  1137. : DEBUG{   ( -- , start compiling debug info )
  1138.     db-installed @ not
  1139.     IF  what's FIND is old.FIND
  1140.         ['] db.find is FIND
  1141.         db-active off
  1142.         db-installed on
  1143.         db-enable on
  1144.         db-latest off
  1145.         state @ dup db-last-state !
  1146.         db-start-state !
  1147.     ELSE ." Debugging already installed!" cr
  1148.     THEN
  1149. ; IMMEDIATE
  1150.  
  1151. : }DEBUG  ( -- , stop compiling debug info )
  1152.     db-installed @
  1153.     IF  what's old.FIND is FIND
  1154.         db-active off
  1155.         db-installed off
  1156.         db-enable off
  1157.         state @ db-start-state @ -
  1158.         IF >newline
  1159.            ." DEBUG{ and }DEBUG must BOTH be in or out of definition!" cr
  1160.         THEN
  1161.     ELSE ." Debugging already removed!" cr
  1162.     THEN
  1163. ; immediate
  1164.  
  1165. : DB.ON
  1166.     db-active on
  1167.     db-dive on  ( for first level )
  1168.     db-touch on
  1169.     db_normal_mode db-mode !
  1170. ;
  1171.  
  1172. : DB.OFF ( -- , turn on interactive debugger )
  1173.     db-active off
  1174.     db-dive off
  1175. ;
  1176.  
  1177. : DEBUG.BREAK ( -- , act like breakpoint )
  1178.     save.regs
  1179.     db.window.on
  1180.     >newline
  1181.     ." User Breakpoint Hit!" cr 
  1182.     db.show.calls
  1183.     db.on
  1184.     db.window.off
  1185.     restore.regs 
  1186. ;
  1187.  
  1188. : DEBUG.START ( -- , turn on interactive debugger )
  1189.     db.vars.off
  1190.     db.0sp
  1191.     db.on
  1192.     db.open.window
  1193. ;
  1194.  
  1195. : DEBUG.STOP
  1196.     db.off
  1197.     db.cleanup
  1198. ;
  1199.  
  1200. : DEBUG  ( <name> -- , debug one word )
  1201.     [compile] '
  1202.     debug.start
  1203.     execute
  1204.     debug.stop
  1205. ;
  1206.  
  1207. : DEBUG.RESET ( -- , reset debugger )
  1208.     nobreaks
  1209.     ' 0= is user.break?
  1210.     db.cleanup
  1211.     db.vars.off
  1212. ;
  1213.  
  1214. \ --------------
  1215. : JUMPTO  ( cfa -- , jump to but don't return )
  1216.     $ 2007 w,    \ move.l tos,d0
  1217.     $ 2E1E w,    \ move.l dsp+,tos
  1218.     $ 4EF40800 , \ jmp    $(org,d0.l)
  1219. ; immediate
  1220.  
  1221. redef? off
  1222. : INCLUDE  ( -- , warn if debugger on )
  1223.     db-installed @
  1224.     IF >newline ." Compiling with Debugger On."
  1225.     THEN
  1226. \ Use JUMPTO in case someone RE-INCLUDES Debugger
  1227.     ' include jumpto
  1228. ;
  1229. : BYE ( -- , close window )
  1230.     db.close.window bye
  1231. ;
  1232.  
  1233. redef? on
  1234.  
  1235. if.forgotten }debug
  1236.  
  1237. false   ( true if testing )
  1238. .IF
  1239. debug{
  1240. : TD ( n -- ) dup 1+ * . ;
  1241. : TD.LOOP ( -- )
  1242.     4 0 DO
  1243.         ." Value = " i . cr
  1244.         i td cr
  1245.     LOOP
  1246. ;
  1247. : TD.RS ( -- )
  1248.     $ 123 >r $ 456 >r $ 777 >r
  1249.     r> . r> . r> .
  1250. ;
  1251. : TD.RS2 ( -- )
  1252.     debug.start
  1253.     $ 123 >r $ 456 >r $ 777 >r
  1254.     r> . r> . r> .
  1255.     debug.stop
  1256. ;
  1257. : TD.DOT ( N -- )
  1258.     s->d tuck dabs
  1259.     <# #s sign #> type
  1260. ;
  1261. }debug
  1262. .THEN
  1263.